home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / ibcl-patches.lisp < prev    next >
Lisp/Scheme  |  1990-01-25  |  4KB  |  130 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'system)
  29.  
  30. ;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
  31. ;;;   in the lambda-list.  The former allows deviation from the CL spec,
  32. ;;;   but what the heck.
  33.  
  34. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  35.  
  36. (defvar *old-defmacro*)
  37.  
  38. (defun new-defmacro (whole env)
  39.   (flet ((call-old-definition (new-whole)
  40.        (funcall *old-defmacro* new-whole env)))
  41.     (if (not (and (consp whole)
  42.           (consp (cdr whole))
  43.           (consp (cddr whole))
  44.           (consp (cdddr whole))))
  45.     (call-old-definition whole)
  46.     (let* ((ll (caddr whole))
  47.            (env-tail (do ((tail ll (cdr tail)))
  48.                  ((not (consp tail)) nil)
  49.                (when (eq '&environment (car tail))
  50.                  (return tail)))))
  51.       (if env-tail
  52.           (call-old-definition (list* (car whole)
  53.                       (cadr whole)
  54.                       (append (list '&environment
  55.                             (cadr env-tail))
  56.                           (ldiff ll env-tail)
  57.                           (cddr env-tail))
  58.                       (cdddr whole)))
  59.           (call-old-definition whole))))))
  60.  
  61. (eval-when (load eval)
  62.   (unless (boundp '*old-defmacro*)
  63.     (setq *old-defmacro* (macro-function 'defmacro))
  64.     (setf (macro-function 'defmacro) #'new-defmacro)))
  65.  
  66. ;;;
  67. ;;; setf patches
  68. ;;;
  69.  
  70. (in-package 'system)
  71.  
  72. (defun get-setf-method (form)
  73.   (multiple-value-bind (vars vals stores store-form access-form)
  74.       (get-setf-method-multiple-value form)
  75.     (unless (listp vars)
  76.         (error 
  77.  "The temporary variables component, ~s, 
  78.   of the setf-method for ~s is not a list."
  79.              vars form))
  80.     (unless (listp vals)
  81.         (error 
  82.  "The values forms component, ~s, 
  83.   of the setf-method for ~s is not a list."
  84.              vals form))
  85.     (unless (listp stores)
  86.         (error 
  87.  "The store variables component, ~s,  
  88.   of the setf-method for ~s is not a list."
  89.              stores form))
  90.     (unless (= (list-length stores) 1)
  91.         (error "Multiple store-variables are not allowed."))
  92.     (values vars vals stores store-form access-form)))
  93.  
  94. (defun get-setf-method-multiple-value (form)
  95.   (cond ((symbolp form)
  96.      (let ((store (gensym)))
  97.        (values nil nil (list store) `(setq ,form ,store) form)))
  98.     ((or (not (consp form)) (not (symbolp (car form))))
  99.      (error "Cannot get the setf-method of ~S." form))
  100.     ((get (car form) 'setf-method)
  101.      (apply (get (car form) 'setf-method) (cdr form)))
  102.     ((get (car form) 'setf-update-fn)
  103.      (let ((vars (mapcar #'(lambda (x)
  104.                              (declare (ignore x))
  105.                              (gensym))
  106.                          (cdr form)))
  107.            (store (gensym)))
  108.        (values vars (cdr form) (list store)
  109.                `(,(get (car form) 'setf-update-fn)
  110.              ,@vars ,store)
  111.            (cons (car form) vars))))
  112.     ((get (car form) 'setf-lambda)
  113.      (let* ((vars (mapcar #'(lambda (x)
  114.                               (declare (ignore x))
  115.                               (gensym))
  116.                           (cdr form)))
  117.         (store (gensym))
  118.         (l (get (car form) 'setf-lambda))
  119.         (f `(lambda ,(car l) 
  120.               (funcall #'(lambda ,(cadr l) ,@(cddr l))
  121.                    ',store))))
  122.        (values vars (cdr form) (list store)
  123.            (apply f vars)
  124.            (cons (car form) vars))))
  125.     ((macro-function (car form))
  126.      (get-setf-method-multiple-value (macroexpand-1 form)))
  127.     (t
  128.      (error "Cannot expand the SETF form ~S." form))))
  129.  
  130.